﻿module internal Octopus.OctopusService.Clips

// https://connect.microsoft.com/VisualStudio/feedback/details/588317/f-project-references-not-working-when-targeting-x64-platform-in-visual-studio-2010#

open System
open System.Collections.Generic
open CLIPSNet
open Octopus.OctopusService.General


type DelegateStr = delegate of CLIPSNet.DataType -> unit
type DelegateStrStr = delegate of CLIPSNet.DataType * CLIPSNet.DataTypes.String -> unit
type DelegateStrMulti = delegate of CLIPSNet.DataType * CLIPSNet.DataTypes.Multifield -> unit

module clipsFunctions =
  let clips_create_newVm (reqId:CLIPSNet.DataType) (nodes:CLIPSNet.DataTypes.Multifield) =
      try
        let reqIdStr = string reqId
        let nodeArray = [| for x in nodes -> string x |]          
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Called clips_create_newVm (create-newvm %s [|%s|])" reqIdStr (String.Join(";",nodeArray)))
        let requestGuid = new Guid(reqIdStr)
        FunctionsCore.allowRequestOfNewVm requestGuid nodeArray
      with e ->
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] clips_create_newVm throws an exception: %s" e.Message)

  let clips_deny_newVm (reqId:CLIPSNet.DataType) (reason:CLIPSNet.DataTypes.String) =
      try
        let reqIdStr = string reqId
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Called clips_deny_newVm (deny-newvm %s \"%s\")" reqIdStr (string reason))
        let requestGuid = new Guid(reqIdStr)
        FunctionsCore.denyRequestOfNewVm requestGuid
      with e ->
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] clips_deny_newVm throws an exception: %s" e.Message)

  let clips_suspend_vm (vmId:CLIPSNet.DataType) =
      try
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Called clips_suspend_vm %s" (string vmId))
        let vmGuid = new Guid(string vmId)
        FunctionsCore.suspendVm vmGuid
      with e ->
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] clips_suspend_vm throws an exception: %s" e.Message)

  let clips_migrate_vm (vmId:CLIPSNet.DataType) (hostName:CLIPSNet.DataTypes.String) =
      try
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Called clips_migrate_vm %s %s" (string vmId) (string hostName))
        let vmGuid = new Guid(string vmId)
        let destNode = string hostName
        FunctionsCore.migrateVm vmGuid destNode
      with e ->
        Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] clips_migrate_vm throws an exception: %s" e.Message)

  let clips_shutdown_node (vmId:CLIPSNet.DataType) =
      Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Called clips_shutdown_node %s" (string vmId))

  let clips_poweron_node (vmId:CLIPSNet.DataType) =
      Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Called clips_poweron_node %s" (string vmId))
      


let mutable env : Environment = null


type private FactDicEntry (pIndex:int64, pParams:string array) =
  let mutable _index = pIndex
  let mutable _params = pParams
  member x.Params with get() = _params and set(v) = _params <- v
  member x.Index with get() = _index and set(v) = _index <- v
  member x.ParamsEqualsTo (p:string array) =
    if x.Params <> null && p <> null && x.Params.Length = p.Length then
      let mutable eq = true
      for i = 0 to (x.Params.Length-1) do eq <- eq && x.Params.[i].Equals(p.[i])
      eq
    else
      x.Params = p

let private factsDictionary = new Dictionary<string, FactDicEntry>()

let private assertIfNew factName =
  if not( factsDictionary.ContainsKey(factName) ) then
    let s = sprintf "(%s)" factName
    let f = env.AssertString(s)
    factsDictionary.[factName] <- new FactDicEntry(f.Index, null)
    f
  else
    null    

let private assertIfChanged factName factParams =
  let mutable factFoundIndex = -1L
  let isNewOrChanged =
      try
        let f = factsDictionary.[factName]
        let changed = not(f.ParamsEqualsTo(factParams))
        factFoundIndex <- f.Index
        changed
      with _ ->
        true        // new

  if isNewOrChanged then
    if factFoundIndex > 0L then
      for x in env.GetFactList() do let xx = x :?> Fact in if xx.Index = factFoundIndex then xx.Retract() |> ignore; xx.Dispose() 
  
    let sb = new System.Text.StringBuilder()
    sb.Append('(').Append(factName).Append(' ') |> ignore
    for x in factParams do sb.Append(x).Append(' ') |> ignore
    sb.Remove(sb.Length-1, 1).Append(')') |> ignore

    let f = env.AssertString(string sb)
    factsDictionary.[factName] <- new FactDicEntry(f.Index, factParams)
    f
  else
    null


let updateAllFacts (hosts:Octopus.OctopusLib.HyperVNode array) (vms:Octopus.OctopusLib.VirtualMachine array) =
    Database.LogFile.writeInLog "[CLIPS] Called updateAllFacts()"
    try
        for node in hosts do
            let memorySizeApprox = node.MemorySize / 1048576UL
            let cpuLoadApprox = (((int node.LastCpuLoad) + 5) / 10) * 10
            let memoryFreeApprox = node.LastMemoryFree / 1048576UL

            //let name0 = sprintf "host-info %s" node.HostName
            //use fact = assertIfChanged name0 parz0

            let names = [| "host-isreachable"; "host-ipaddress"; "host-cpucount"; "host-memorysize"; "host-cpuload"; "host-memoryfree" |]
            let parz0 = [| (string node.IsReachable).ToUpper(); node.IpAddress; string node.CpuCount; string memorySizeApprox; string cpuLoadApprox; string memoryFreeApprox |]

            use fact = assertIfNew (sprintf "host-name %s" node.HostName)
            for i = 0 to (names.Length-1) do
              let name = sprintf "%s %s" names.[i] node.HostName
              let parz = [| parz0.[i] |]
              use fact = assertIfChanged name parz
              ()

        for vm in vms do
            let memorySizeApprox = vm.MemorySize / 1048576UL

            //let name0 = sprintf "vm-info %s" (string vm.Guid)
            //use fact = assertIfChanged name0 parz0

            let vmstate =
              match (vm.OctopusState, vm.HyperVState) with
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Running -> 1
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Stopped -> 2
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Paused -> 3
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Suspended -> 4
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Pausing
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Resuming
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Saving
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Stopping
              | Octopus.OctopusLib.OctopusVmState.Configuring , _
              | Octopus.OctopusLib.OctopusVmState.Checkpointing, _
              | Octopus.OctopusLib.OctopusVmState.Migrating, _                                  -> 10
              | Octopus.OctopusLib.OctopusVmState.Deleting, _
              | Octopus.OctopusLib.OctopusVmState.Deleted, _
              | Octopus.OctopusLib.OctopusVmState.CreationFailed, _                             -> 100
              | Octopus.OctopusLib.OctopusVmState.Normal, Octopus.OctopusLib.HyperVState.Unknown
              | Octopus.OctopusLib.OctopusVmState.GenericError, _                               -> 101
              | _, _                                                                            -> 102

            let cpuLoad =
              try 
                let node = hosts |> Array.find (fun x -> x.HostName.ToUpper() = vm.CurrentServer.ToUpper())
                if node.IsReachable then
                  let hfvms = HyperF.HyperF.get_VMSummary (Some vm.CurrentServer) (vm.HyperVGuid)
                  hfvms.CpuLoad
                else
                  -1
              with _ ->
                  -1              

            let names = [| "vm-name"; "vm-owner"; "vm-hostname"; "vm-server"; "vm-cpucount"; "vm-memorysize"; "vm-ischeckpointed"; "vm-ipaddress"; "vm-templateid"; "vm-state"; "vm-cpuload" |]
            let parz0 = [| "\"" + vm.HostName + "\""; vm.OwnerName; vm.HostName; vm.CurrentServer; string vm.CpuCount; string memorySizeApprox; (string vm.IsCheckpointed); (string vm.Ipv4Address); string vm.VmTemplateID; string vmstate; string cpuLoad |]
            for i = 0 to (names.Length-1) do
              let name = sprintf "%s %s" names.[i] (string vm.OctopusGuid)
              let parz = [| parz0.[i] |]
              use fact = assertIfChanged name parz
              ()

    with e ->
        Database.LogFile.writeInLog ("[CLIPS] Exception in updateAllFacts: " + e.Message)
        Database.LogFile.writePlainText e.StackTrace

    Database.ClipsLogFile.writeInLog "Updated the CLIPS environment:"
    let factlist = env.GetFactList()
    for fact in factlist do
      let f = fact :?> Fact
      Database.ClipsLogFile.writePlainText (sprintf "%d: %s" f.Index f.PPForm)
    Database.ClipsLogFile.writeBlank()


let assertEvent_creatingNewVm (vmd:Octopus.OctopusLib.VirtualMachineRequested) =
  let str = sprintf "(event-creating-vm %s %s %d %d %d)" (string vmd.OctopusGuid) vmd.OwnerName vmd.NumberOfVm vmd.CpuCount (vmd.MemorySize / 1048576UL)
  Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Asserting %s" str)
  env.AssertString(str) |> ignore

let assert_triggeringRun () =
  let str = "(triggeringRun)"
  Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Asserting %s" str)
  env.AssertString(str) |> ignore


//-----------------------------------------------------------

let initEnv () =
  Database.LogFile.writeInLog "[CLIPS] Called initEnv"
  if env <> null then env.Clear(); env.Dispose()
  env <- new Environment()
  new UserFunction(env, new DelegateStrMulti(clipsFunctions.clips_create_newVm), "create-newvm") |> ignore
  new UserFunction(env, new DelegateStrStr(clipsFunctions.clips_deny_newVm), "deny-newvm") |> ignore
  new UserFunction(env, new DelegateStr(clipsFunctions.clips_suspend_vm), "suspend-vm") |> ignore
  new UserFunction(env, new DelegateStrStr(clipsFunctions.clips_migrate_vm), "migrate-vm") |> ignore
  new UserFunction(env, new DelegateStr(clipsFunctions.clips_shutdown_node), "shutdown-node") |> ignore
  new UserFunction(env, new DelegateStr(clipsFunctions.clips_poweron_node), "poweron-node") |> ignore
  
  let clipsDefaultFile =
      try (getFile getServiceBinPath "clips-default.clp").FullName
      with _ -> failwith "Clips file \"clips-default.clp\" not found."

  let n = env.Load(clipsDefaultFile) in
    if n = 1 then Database.LogFile.writeInLog "[CLIPS] loaded clips-default.clp"
    else Database.LogFile.writeInLog (sprintf "[CLIPS] error loading clips-default.clp (error: %d)" n)


let task_updateClips () =
  let hosts = Database.HyperVNodes.getHyperVNodes ()
  let vms = Database.VirtualMachines.getAllVm ()
  updateAllFacts hosts vms

  Database.ClipsLogFile.writeInLog "[CLIPS] Called Run()"
  assert_triggeringRun ()
  try
    let i = env.Run()
    Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Run() ended with return=%d" i)
  with e ->
    Database.ClipsLogFile.writeInLog (sprintf "[CLIPS] Run() throws an exception: %s" e.Message)
